home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / library.lisp < prev    next >
Encoding:
Text File  |  1992-09-11  |  5.0 KB  |  144 lines
  1. ;;; (C) Copyright 1990,1991 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defun lookup-library (lib-name)
  4.   (gethash lib-name *libraries*))
  5.  
  6. (defun lookup-initialized-library (lib-name)
  7.   (let ((l (lookup-library lib-name)))
  8.     (if (or (null l) (= (length (library-symbol-table l)) 0))
  9.     (read-library-link-info lib-name)
  10.     l)))
  11.  
  12. (defun set-lookup-library (lib-name value)
  13.   (setf (gethash lib-name *libraries*) value))
  14.  
  15. (defsetf lookup-library set-lookup-library)
  16.  
  17. (defun library-info-file (lib-name)
  18.   (format nil "~A/lib/lib~A.info" *root-directory* (string-downcase lib-name)))
  19.  
  20. (defun library-unix-name (library)
  21.   (format nil "~Alib~A.so.~A"
  22.       (library-directory library)
  23.       (string-downcase (library-name library))
  24.       (library-version library)))
  25.  
  26. (defun write-library-info (lib)
  27.   (warn "Writing ~A library information" (library-name lib))
  28.   (let ((*package* *compiler-package*)
  29.     (pinfo (library-procedure-info lib))
  30.     (c-type-info (library-c-type-info lib)))
  31.     (with-open-file (output (library-info-file (library-name lib))
  32.                 :direction :output)
  33.       (format output "~D~%" (+ (hash-table-count pinfo)
  34.                    (hash-table-count c-type-info)))
  35.       (write-c-type-info c-type-info output)
  36.       (write-procedure-info pinfo output)
  37.       (write-library-proclaims lib output)
  38.       (format output "~S~%" (library-version lib))
  39.       (format output "~S~%" (library-init-thunk lib))
  40.       (write-library-symbols lib output)
  41.       lib)))
  42.  
  43. (defun write-library-symbols (lib output)
  44.   (let ((symbol-table (library-symbol-table lib)))
  45.     (loop for app-package being the array-elements of symbol-table
  46.       do (maphash
  47.           #'(lambda (sym appsym)
  48.           (format output "~S ~S ~S ~S~%"
  49.               sym
  50.               (let ((v (application-symbol-value appsym)))
  51.                 (if (eq v *unbound*)
  52.                 'unbound
  53.                 v))
  54.               (application-symbol-function appsym)
  55.               (application-symbol-flags appsym)))
  56.           (application-package-symbols app-package)))))
  57.  
  58. (defun write-library-proclaims (lib output)
  59.   (let ((*package* *compiler-package*)
  60.     (*print-circle* nil)
  61.     (*print-array* t)
  62.     (*print-structure* t)
  63.     (proclaims (library-proclaims lib)))
  64.     (format output "~D~%" (length proclaims))
  65.     (dolist (p proclaims)
  66.       (format output ":proclaim ~S~%" p))))
  67.  
  68. (defun read-library-link-info (name)
  69.   (warn "Reading ~A library linking information" name)
  70.   (let ((*package* *compiler-package*))
  71.     (with-open-file (input (library-info-file name))
  72.       ;; Discard procedure info - let the compiler read that if needed.
  73.       ;; GAG! READ doesn't eat newlines, so we eat them explicitly
  74.       (dotimes (i (prog1 (read input t) (read-line input)))
  75.     (read-line input))
  76.       ;; Discard proclaims info
  77.       (dotimes (i (prog1 (read input t) (read-line input)))
  78.     (read-line input))
  79.       (let* ((version (read input t))
  80.          (init-thunk (read input t))
  81.          (symbol-table (new-symbol-table))
  82.          (lib (or (lookup-library name) (define-library name version))))
  83.     (setf (library-init-thunk lib) init-thunk)
  84.     (setf (library-symbol-table lib) symbol-table)
  85.     (read-library-symbols symbol-table input)
  86.     (setf (lookup-library name) lib)
  87.     lib))))
  88.  
  89. (defun read-library-symbols (symbol-table input)
  90.   (loop for symbol = (read input nil input)
  91.     until (eq symbol input)
  92.     do (let ((value (read input t))
  93.          (function (read input t))
  94.          (flags (read input t))
  95.          (app-sym (intern-application-symbol-in-symbol-table
  96.                symbol symbol-table)))
  97.          (setf (application-symbol-value app-sym)
  98.            (if (eq value 'unbound) *unbound* value))
  99.          (setf (application-symbol-function app-sym) function)
  100.          (setf (application-symbol-flags app-sym) flags))))
  101.  
  102. (defun read-library-proclaims (input)
  103.   (let ((*package* *compiler-package*))
  104.     (dotimes (i (read input t))
  105.       (read input t)            ; discard :proclaims
  106.       (proclaim-w (eval (read input t))))))
  107.  
  108. (defun read-all-libraries-compiler-info ()
  109.   (dolist (l *default-libraries*)
  110.     (read-library-compiler-info l)))
  111.  
  112. (defun read-library-compiler-info (lib-name)
  113.   (let ((procedure-info-file (library-info-file lib-name)))
  114.     (when (probe-file procedure-info-file)
  115.       (warn "Loading ~A library compiler information" (symbol-name lib-name))
  116.       (with-open-file (input procedure-info-file)
  117.     (read-procedure-info input)
  118.     (read-library-proclaims input)))
  119.     lib-name))
  120.  
  121. (defun define-library (name version
  122.                 &key
  123.                 (directory (format nil "~A/lib/" *root-directory*))
  124.                 lisp-files
  125.                 other-object-files
  126.                 (init-thunk (format nil "init_library_~A"
  127.                         (string-downcase name))))
  128.   (setf (gethash name *libraries*)
  129.     (make-library :name name
  130.               :version version
  131.               :directory directory
  132.               :lisp-files lisp-files
  133.               :init-thunk init-thunk
  134.               :symbol-table (new-symbol-table)
  135.               :procedure-info (new-function-info-table)
  136.               :c-type-info (make-hash-table :size 300)
  137.               :proclaims nil
  138.               :other-object-files other-object-files)))
  139.  
  140. (defun library-all-object-files (library)
  141.   (append (mapcar #'binary-pathname (library-lisp-files library))
  142.       (mapcar #'binary-pathname  (library-other-object-files library))))
  143.  
  144.